home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / MODGLO~1.CLS < prev    next >
Text File  |  1997-06-14  |  8KB  |  241 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CModGlobDelFilter"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. ' CModGlobDelFilter implements IFilter
  13. Implements IFilter
  14.  
  15. Enum EProcType
  16.     eptNone
  17.     eptMethodSub
  18.     eptMethodFunc
  19.     eptPropertyGet
  20.     eptPropertyLet
  21.     eptPropertySet
  22.     eptUnknown
  23. End Enum
  24.  
  25. Private sSource As String, sTarget As String
  26. Private sModule As String, sCallLine As String, sArgList As String
  27. Private fLineContinue As Boolean, eptType As EProcType
  28. Private sName As String
  29.  
  30. ' CModGlobDelFilter-specific methods and properties
  31. Public Property Let Name(sNameA As String)
  32.     sName = sNameA
  33. End Property
  34. Public Property Get Name() As String
  35.     Name = sName
  36. End Property
  37.  
  38. ' Implementation of IFilter interface
  39. Private Property Get IFilter_Source() As String
  40.     IFilter_Source = sSource
  41. End Property
  42. Private Property Let IFilter_Source(sSourceA As String)
  43.     sSource = sSourceA
  44. End Property
  45.  
  46. Private Property Get IFilter_Target() As String
  47.     IFilter_Target = sTarget
  48. End Property
  49. Private Property Let IFilter_Target(sTargetA As String)
  50.     sTarget = sTargetA
  51. End Property
  52.  
  53. ' Great big, long, complex state machine all in one ugly chunk
  54. Private Function IFilter_Translate(sLine As String, _
  55.                                    ByVal iLine As Long) As EChunkAction
  56.     Dim sTok As String, sSep As String
  57.     sSep = " (" & sTab
  58.     IFilter_Translate = ecaSkip ' We'll skip most lines
  59.     
  60.     ' Handle first line of module
  61.     If iLine = 1 Then
  62.         sTok = GetQToken(sLine, sSep)
  63.         BugAssert sTok = "Attribute"
  64.         sTok = GetQToken(sEmpty, sSep)
  65.         BugAssert sTok = "VB_Name"
  66.         sTok = GetQToken(sEmpty, sSep)
  67.         BugAssert sTok = "="
  68.         sModule = GetQToken(sEmpty, sSep)
  69.         ' Use default global name if global name isn't already set
  70.         If sName = sEmpty Then
  71.             ' Remove this block if you don't use M as a tag on standard modules
  72.             If Left$(sModule, 1) = "M" Then
  73.                 sName = "G" & Right$(sModule, Len(sModule) - 1)
  74.             Else
  75.                 sName = "G" & sModule
  76.             End If
  77.         End If
  78.         sLine = "VERSION 1.0 CLASS" & sCrLf & _
  79.                 "BEGIN" & sCrLf & _
  80.                 "  MultiUse = -1  'True" & sCrLf & _
  81.                 "END" & sCrLf & _
  82.                 "Attribute VB_Name = " & sQuote2 & sName & sQuote2 & sCrLf & _
  83.                 "Attribute VB_GlobalNameSpace = True" & sCrLf & _
  84.                 "Attribute VB_Creatable = True" & sCrLf & _
  85.                 "Attribute VB_PredeclaredId = False" & sCrLf & _
  86.                 "Attribute VB_Exposed = True"
  87.         IFilter_Translate = ecaTranslate
  88.         Exit Function
  89.     End If
  90.     
  91.     ' Don't skip empty lines
  92.     If sLine = sEmpty Then
  93.         IFilter_Translate = ecaTranslate
  94.         Exit Function
  95.     End If
  96.     
  97.     ' Special case for line continuation on procedure definitions
  98.     If Not fLineContinue Then
  99.     
  100.         ' Get first token
  101.         sTok = GetQToken(sLine, sSep)
  102.     
  103.         ' Skip Public modifier
  104.         If sTok = "Public" Then sTok = GetQToken(sEmpty, sSep)
  105.     
  106.         ' Look for Procedures
  107.         Select Case sTok
  108.         ' Create the delegated procedure
  109.         Case "Attribute", "Option"
  110.             ' Pass Attribute and Option lines through unchanged regardless of position
  111.             IFilter_Translate = ecaTranslate
  112.             sTok = GetQToken(sEmpty, sSep)
  113.             Exit Function
  114.         Case "Sub"
  115.             ' Make ending line
  116.             eptType = eptMethodSub
  117.             sTok = GetQToken(sEmpty, sSep)
  118.             sCallLine = "   " & sModule & "." & sTok & " "
  119.         Case "Function"
  120.             ' Make ending line
  121.             eptType = eptMethodFunc
  122.             sTok = GetQToken(sEmpty, sSep)
  123.             sCallLine = "    " & sTok & " = " & sModule & "." & sTok & "("
  124.         Case "Property"
  125.             ' Make ending line
  126.             sTok = GetQToken(sEmpty, sSep)
  127.             ' Handle different property types
  128.             Select Case sTok
  129.             Case "Get"
  130.                 eptType = eptPropertyGet
  131.                 sTok = GetQToken(sEmpty, sSep)
  132.                 sCallLine = "   " & sTok & " = " & sModule & "." & sTok
  133.             Case "Let"
  134.                 eptType = eptPropertyLet
  135.                 sTok = GetQToken(sEmpty, sSep)
  136.                 sCallLine = "   " & sModule & "." & sTok & " = " & sTok
  137.             Case "Set"
  138.                 eptType = eptPropertySet
  139.                 sTok = GetQToken(sEmpty, sSep)
  140.                 sCallLine = "   " & "Set " & sModule & "." & sTok & " = " & sTok
  141.             End Select
  142.         Case sEmpty
  143.             IFilter_Translate = ecaTranslate
  144.             Exit Function
  145.         Case Else
  146.             ' Skip all other lines
  147.             IFilter_Translate = ecaSkip
  148.             Exit Function
  149.         End Select
  150.         ' Get the first parameter token (space separated only)
  151.         sTok = GetQToken(sEmpty, " ")
  152.     Else
  153.         sTok = GetQToken(sLine, " ")
  154.     End If
  155.     
  156.     ' Process arguments
  157.     Dim cParams As Long
  158.     Do While sTok <> sEmpty
  159.         If Left$(sTok, 1) = "(" Then sTok = Mid$(sTok, 2)
  160.         Select Case sTok
  161.         Case "ByVal", "ByRef", "Optional", "ParamArray"
  162.             ' Ignore modifiers
  163.             GoTo NextCase2
  164.         Case "_"
  165.             ' Line continuation
  166.             fLineContinue = True
  167.             IFilter_Translate = ecaTranslate
  168.             Exit Function
  169.         Case ")"
  170.             ' Empty argument list
  171.             If Right$(sCallLine, 1) = "(" Then
  172.                 sCallLine = Left$(sCallLine, Len(sCallLine) - 1)
  173.             End If
  174.             Exit Do
  175.         End Select
  176.         cParams = cParams + 1
  177.         sArgList = sArgList & sTok
  178.         ' Get As
  179.         sTok = GetQToken(sEmpty, " ")
  180.         If sTok <> "As" Then
  181.             sArgList = sEmpty
  182.             sCallLine = "    ' Can't translate"
  183.             Exit Do
  184.         End If
  185.         ' Get type with ending , or )
  186.         sTok = GetQToken(sEmpty, sSep)
  187.         Dim sNext As String
  188. NextCase:
  189.         sNext = Right$(sTok, 1)
  190.         Select Case sNext
  191.         Case ","
  192.             sArgList = sArgList & sNext & " "
  193.         Case ")"
  194.             If eptType = eptMethodFunc Then sArgList = sArgList & sNext
  195.             Exit Do
  196.         Case Else
  197.             ' If no terminating , or ), throw away optional argument
  198.             sTok = GetQToken(sEmpty, sSep)
  199.             If sTok <> "=" Then
  200.                 sArgList = sEmpty
  201.                 sCallLine = "    ' Can't translate"
  202.                 Exit Do
  203.             End If
  204.             sTok = GetQToken(sEmpty, sSep)
  205.             GoTo NextCase
  206.         End Select
  207.         ' Next parameter name
  208. NextCase2:
  209.         sTok = GetQToken(sEmpty, " ")
  210.     Loop
  211.     
  212.     ' Add the delegated line
  213.     Select Case eptType
  214.     Case eptMethodSub
  215.         sLine = sLine & sCrLf & sCallLine & sArgList & sCrLf & "End Sub"
  216.     Case eptMethodFunc
  217.         sLine = sLine & sCrLf & sCallLine & sArgList & sCrLf & "End Function"
  218.     Case eptPropertyLet, eptPropertySet
  219.         If cParams > 1 Then
  220.             sArgList = sEmpty
  221.             sCallLine = "    ' Can't translate"
  222.         End If
  223.         sLine = sLine & sCrLf & sCallLine & sArgList & sCrLf & "End Property"
  224.     Case eptPropertyGet
  225.         If cParams Then
  226.             sArgList = sEmpty
  227.             sCallLine = "    ' Can't translate"
  228.         End If
  229.         sLine = sLine & sCrLf & sCallLine & sArgList & sCrLf & "End Property"
  230.     End Select
  231.     ' Reset defaults
  232.     sArgList = sEmpty
  233.     eptType = eptNone
  234.     sCallLine = sEmpty
  235.     fLineContinue = False
  236.     IFilter_Translate = ecaTranslate
  237.     Exit Function
  238.  
  239. End Function
  240.  
  241.